{
  This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
  the Free Software Foundation; version 2 of the License.
   
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
}

// Copyright (c) 2010 2011 2012 - J. Aldo G. de Freitas Junior

{$mode objfpc}
{$H+}

Unit
	Tree;

Interface

Uses
	Classes,
	SysUtils,
	Contnrs,
	RTTIObjects,
	BaseException,
	StrUtils,
	NameValue;

Const
	ccFocusCapability = 'focusable';

Type
	TTreeNode = Class;
	TTreeNodeList = Array Of TTreeNode;
	TTreeNodeClass = Class Of TTreeNode;
	TTreeClassFactory = Class;
	ETreeNode = Class(Exception);

	TTreeNode = Class(TRTTIObject)
	Private
		fOwner: TTreeNode;
		fChilds: TTreeNodeList;
		fCurrent: Integer;
		fFactory : TTreeClassFactory;
	Public
		{ Constructor And Destructor }
		Constructor Create(Const aOwner : TTreeNode); Virtual;
		Destructor Destroy; Override;
		Procedure AfterLoad; Virtual;
		{ Child manipulation }
		Function AddChild(Const aNode : TTreeNode): TTreeNode;
		Procedure Delete(Const aNode : TTreeNode);
		Procedure Purge;
		{ Child Navigation }
		Procedure First;
		Procedure Next;
		Procedure Previous;
		Procedure Last;
		Function IsBeforeFirst: Boolean;
		Function IsAtFirst: Boolean;
		Function IsAtMiddle: Boolean;
		Function IsAtLast: Boolean;
		Function IsAfterLast: Boolean;
		Function GetFirst: TTreeNode;
		Function GetCurrent: TTreeNode;
		Function GetNext: TTreeNode;
		Function GetPrevious: TTreeNode;
		Function GetLast: TTreeNode;
		Function GetCurrentAndIncrement: TTreeNode;
		Function GetCurrentAndDecrement: TTreeNode;
		Function GetChildByNumber(Const aIndex : Integer): TTreeNode;
		Function GetCurrentIndex: Integer;
		Procedure SetCurrentIndex(Const aIndex : IntegeR);
		{ Item location and info }
		Function GetMyIndex: Integer;
		Function FindRoot: TTreeNode;
		Function NumericalName: String; Virtual;
		Function IndexedName: String; Virtual;
		Function Find(Const aName : String): TTreeNode;
		Function HasChildNamed(Const aName : String): Boolean;
		Class Function RegisteredName : String; Virtual;
		Procedure Propagate(Const aEventName : String; Const aObject : TObject);
		{ Properties }
		Property Owner: TTreeNode Read fOwner;
		Property Childs: TTreeNodeList Read fChilds Write fChilds;
		Property Factory : TTreeClassFactory Read fFactory;
	End;

	TTreeNodeIterator = Class
	Public
		Procedure Visit(Const aTarget : TTreeNode); Virtual;
		Procedure Process(Const aTarget : TTreeNode); Virtual; Abstract;
		Procedure OnNoChild(Const aTarget : TTreeNode); Virtual;
		Procedure OnBeforeSingleChild(Const aTarget : TTreeNode); Virtual;
		Procedure OnAfterSingleChild(Const aTarget : TTreeNode); Virtual;
		Procedure OnBeforeAllChilds(Const aTarget : TTreeNode); Virtual;
		Procedure OnAfterAllChilds(Const aTarget : TTreeNode); Virtual;
		Procedure OnBeforeChild(Const aTarget : TTreeNode); Virtual;
		Procedure OnAfterChild(Const aTarget : TTreeNode); Virtual;
	End;

	TTreeClassFactory = Class(TObject)
	Private
		fHash : TFPHashList;
		fDefaultClass : TTreeNodeClass;
	Public
		Constructor Create; Virtual;
		Destructor Destroy; Override;
		Procedure Register(Const aClassInfo : TTreeNodeClass);
		Function Build(Const aClassName : String; Const aOwner : TTreeNode): TTreeNode;
		Function IsRegisteredClass(Const aClassName : String): Boolean;
		Procedure Clear;
		Property RegisteredClasses : TFPHashList Read fHash;
		Property DefaultClass : TTreeNodeClass Read fDefaultClass Write fDefaultClass;
	End;

Implementation

Function ReportRangeError(Const aCurrent : Integer; Const aNode : TTreeNode): String;
Begin
	If Length(aNode.Childs) > 0 Then
		Result := 'Access out of bounds (Max = ' + 
			IntToStr(High(aNode.Childs)) + ', Min = ' + 
			IntToStr(Low(aNode.Childs)) + ', Tried = ' + 
			IntToStr(aCurrent) + ').'
	Else
		Result := 'Access out of bounds (Node has no childs).';
End;

// TTreeNode

Constructor TTreeNode.Create(Const aOwner : TTreeNode);
Begin
	Inherited Create;
	InitRTTI;
	fOwner := aOwner;
	If Assigned(fOwner) Then
		fOwner.AddChild(Self);
	SetLength(fChilds, 0);
	fCurrent := Low(fChilds);
	fFactory := TTreeClassFactory.Create;
End;

Destructor TTreeNode.Destroy;
Begin
	Purge;
	FreeAndNil(fFactory);
	DoneRTTI;
	Inherited Destroy;
End;

Procedure TTreeNode.AfterLoad;
Begin
	First;
	While Not IsAfterLast Do
	Begin
		GetCurrent.AfterLoad;
		Next;
	End;
End;

Function TTreeNode.AddChild(Const aNode : TTreeNode): TTreeNode;
Begin
	SetLength(fChilds, Length(fChilds) + 1);
	fChilds[High(fChilds)] := aNode;
	Result := aNode;
End;

Procedure TTreeNode.Delete(Const aNode : TTreeNode);
Var
	lCtrl1,
	lCtrl2 : Integer;
	lFound : Boolean;
Begin
	If Length(fChilds) > 0 Then
	Begin
		lFound := False;
		For lCtrl1 := Low(fChilds) To High(fChilds) Do
			If fChilds[lCtrl1] = aNode Then
				If Not fChilds[lCtrl1].ReadOnly Then
				Begin
					lFound := True;
					FreeAndNil(fChilds[lCtrl1]);
					For lCtrl2 := lCtrl1 To High(fChilds) - 1 Do
						fChilds[lCtrl2] := fChilds[lCtrl2 + 1];
					SetLength(fChilds, Length(fChilds) - 1);
					Break;
				End
			Else
				Raise ETreeNode.Create('Node is read-only.');
		If Not(lFound) Then
			Raise ETreeNode.Create('Node not found.');
	End
	Else
		Raise ETreeNode.Create('Cannot delete from an empty set.');
End;

Procedure TTreeNode.Purge;
Var
	lCtrl : Integer;
Begin
	// Debug WriteLn('Purge called for ', IndexedName);
	If Length(fChilds) > 0 Then
		For lCtrl := Low(fChilds) To High(fChilds) Do
			FreeAndNil(fChilds[lCtrl]);
	SetLength(fChilds, 0);
End;

Procedure TTreeNode.First;
Begin
	fCurrent := Low(fChilds);
End;

Procedure TTreeNode.Next;
Begin
	Inc(fCurrent);
End;

Procedure TTreeNode.Previous;
Begin
	Dec(fCurrent);
End;

Procedure TTreeNode.Last;
Begin
	fCurrent := High(fChilds);
End;

Function TTreeNode.IsBeforeFirst: Boolean;
Begin
	Result := fCurrent < Low(fChilds);
End;

Function TTreeNode.IsAtFirst: Boolean;
Begin
	Result := fCurrent = Low(fChilds);
End;

Function TTreeNode.IsAtMiddle: Boolean;
Begin
	Result := (fCurrent > Low(fChilds)) And (fCurrent < High(fChilds));
End;

Function TTreeNode.IsAtLast: Boolean;
Begin
	Result := fCurrent = High(fChilds);
End;

Function TTreeNode.IsAfterLast: Boolean;
Begin
	Result := fCurrent > High(fChilds);
End;

Function TTreeNode.GetFirst: TTreeNode;
Begin
	If Length(fChilds) > 0 Then
		Result := fChilds[Low(fChilds)]
	Else
	Begin
		Result := Nil;
		Raise ETreeNode.Create(ReportRangeError(0, Self));
	End;
End;

Function TTreeNode.GetCurrent: TTreeNode;
Begin
	If (fCurrent >= Low(fChilds)) And (fCurrent <= High(fChilds)) Then
		Result := fChilds[fCurrent]
	Else
		Raise ETreeNode.Create(ReportRangeError(fCurrent, Self));
End;

Function TTreeNode.GetNext: TTreeNode;
Begin
	If ((fCurrent + 1) >= Low(fChilds)) And ((fCurrent + 1) <= High(fChilds)) Then
		Result := fChilds[fCurrent + 1]
	Else
	Begin
		Result := Nil;
		Raise ETreeNode.Create(ReportRangeError(fCurrent + 1, Self));
	End;
End;

Function TTreeNode.GetPrevious: TTreeNode;
Begin
	If ((fCurrent - 1) >= Low(fChilds)) And ((fCurrent - 1) <= High(fChilds)) Then
		Result := fChilds[fCurrent - 1]
	Else
	Begin
		Result := Nil;
		Raise ETreeNode.Create(ReportRangeError(fCurrent - 1, Self));
	End;
End;

Function TTreeNode.GetLast: TTreeNode;
Begin
	If Length(fChilds) > 0 Then
		Result := fChilds[High(fChilds)]
	Else
	Begin
		Result := Nil;
		Raise ETreeNode.Create(ReportRangeError(0, Self));
	End;
End;

Function TTreeNode.GetCurrentAndIncrement: TTreeNode;
Begin
	Result := GetCurrent;
	Next;
End;

Function TTreeNode.GetCurrentAndDecrement: TTreeNode;
Begin
	Result := GetCurrent;
	Previous;
End;

Function TTreeNode.GetChildByNumber(Const aIndex : Integer): TTreeNode;
Begin
	If (aIndex >= Low(fChilds)) And (aIndex <= High(fChilds)) Then
		Result := fChilds[aIndex]
	Else
		Raise ETreeNode.Create(ReportRangeError(aIndex, Self));
End;

Function TTreeNode.GetCurrentIndex : Integer;
Begin
	Result := fCurrent;
End;

Procedure TTreeNode.SetCurrentIndex(Const aIndex : Integer);
Begin
	fCurrent := aIndex;
End;

Function TTreeNode.GetMyIndex: Integer;
Var
	lSavedIndex : Integer;
Begin
	Result := 0;
	If Assigned(fOwner) Then
	Begin
		lSavedIndex := fOwner.GetCurrentIndex;
		fOwner.First;
		While Not fOwner.IsAfterLast Do
		Begin
			If fOwner.GetCurrent = Self Then
				Result := fOwner.GetCurrentIndex;
			fOwner.Next;
		End;
		fOwner.SetCurrentIndex(lSavedIndex);
	End;
End;

Function TTreeNode.FindRoot: TTreeNode;
Begin
	If Assigned(fOwner) Then
		Result := fOwner.FindRoot
	Else
		Result := Self;
End;

Function TTreeNode.NumericalName: String;
Begin
	If Assigned(Owner) Then
		If Assigned(Owner.Owner) Then
			Result := Owner.NumericalName + '.[' + IntToStr(GetMyIndex) + ']'
		Else
			Result := '[' + IntToStr(GetMyIndex) + ']';
End;

Function TTreeNode.IndexedName : String;
Begin
	If Assigned(Owner) Then
		If Assigned(Owner.Owner) Then
			Result := Owner.IndexedName + '.' + RegisteredName
		Else
			Result := RegisteredName;
End;

Function TTreeNode.Find(Const aName : String): TTreeNode;
Var
	lCtrl : Integer;
Begin
	Result := Nil;
	For lCtrl := Low(Childs) To High(Childs) Do
		If LowerCase(Childs[lCtrl].RegisteredName) = LowerCase(aName) Then
		Begin
			Result := Childs[lCtrl];
			Break;
		End;
	If Result = Nil Then
		Raise ETreeNode.Create('Theres no child named ' + aName + ' in the node ' + IndexedName);
End;

Function TTreeNode.HasChildNamed(Const aName : String): Boolean;
Var
	lCtrl : Integer;
Begin
	Result := False;
	For lCtrl := Low(Childs) To High(Childs) Do
		If LowerCase(Childs[lCtrl].RegisteredName) = LowerCase(aName) Then
		Begin
			Result := True;
			Break;
		End;
End;

Class Function TTreeNode.RegisteredName : String;
Begin
	Result := 'node';
End;

Procedure TTreeNode.Propagate(Const aEventName : String; Const aObject : TObject);
Var
	lSave : Integer;
Begin
	Try
		lSave := GetCurrentIndex;
		DispatchEvent(aEventName, aObject);
		First;
		While Not IsAfterLast Do
		Begin
			GetCurrent.Propagate(aEventName, aObject);
			Next;
		End;
	Finally
		SetCurrentIndex(lSave);
	End;
End;

{ TTreeNodeIterator }

Procedure TTreeNodeIterator.Visit(Const aTarget : TTreeNode);
Var
	lCtrl : Integer;
Begin
	Process(aTarget);
	If Length(aTarget.Childs) > 1 Then
	Begin
		OnBeforeAllChilds(aTarget);
		For lCtrl := Low(aTarget.Childs) To High(aTarget.Childs) Do
		Begin
			OnBeforeChild(aTarget);
			Visit(aTarget.Childs[lCtrl]);
			OnAfterChild(aTarget);
		End;
		OnAfterAllChilds(aTarget);
	End
	Else If Length(aTarget.Childs) = 1 Then
	Begin
		OnBeforeSingleChild(aTarget);
		Visit(aTarget.GetFirst);
		OnAfterSingleChild(aTarget);
	End
	Else If Length(aTarget.Childs) < 1 Then
		OnNoChild(aTarget);
End;

Procedure TTreeNodeIterator.OnNoChild(Const aTarget : TTreeNode);
Begin
End;

Procedure TTreeNodeIterator.OnBeforeSingleChild(Const aTarget : TTreeNode);
Begin
End;

Procedure TTreeNodeIterator.OnAfterSingleChild(Const aTarget : TTreeNode);
Begin
End;

Procedure TTreeNodeIterator.OnBeforeAllChilds(Const aTarget : TTreeNode);
Begin
End;

Procedure TTreeNodeIterator.OnAfterAllChilds(Const aTarget : TTreeNode);
Begin
End;

Procedure TTreeNodeIterator.OnBeforeChild(Const aTarget : TTreeNode);
Begin
End;

Procedure TTreeNodeIterator.OnAfterChild(Const aTarget : TTreeNode);
Begin
End;

{ TTreeClassFactory }

Constructor TTreeClassFactory.Create;
Begin
	Inherited Create;
	fHash := TFPHashList.Create;
End;

Destructor TTreeClassFactory.Destroy; 
Begin
	FreeAndNil(fHash);
	Inherited Destroy;
End;

Procedure TTreeClassFactory.Register(Const aClassInfo : TTreeNodeClass);
Begin
	fHash.Add(aClassInfo.RegisteredName, Pointer(aClassInfo));
End;

Function TTreeClassFactory.Build(Const aClassName : String; Const aOwner : TTreeNode): TTreeNode;
Var
	lIndex : Integer;
	lClass : TTreeNodeClass;
Begin
	lIndex := fHash.FindIndexOf(aClassName);
	If lIndex >= 0 Then
		lClass := TTreeNodeClass(fHash.Items[lIndex])
	Else
		Raise ETreeNode.Create('No registered class for ' + aClassName);
	// lClass := fDefaultClass;
	Result := lClass.Create(aOwner);
End;

Function TTreeClassFactory.IsRegisteredClass(Const aClassName : String): Boolean;
Begin
	Result := fHash.FindIndexOf(aClassName) >= 0;
End;

Procedure TTreeClassFactory.Clear;
Begin
	fHash.Clear;
End;

End.
